home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacMETH 3.2.1 / Sources / MacC3.3 / M2CA.MOD < prev    next >
Encoding:
Modula Implementation  |  1992-05-29  |  18.8 KB  |  383 lines  |  [TEXT/MEDT]
  1. IMPLEMENTATION MODULE M2CA; (* HS 19.4.85 / 10.6.86 / 29.2.92; WH 9.5.85 / 27.6.85 *)
  2.  
  3.   FROM SYSTEM IMPORT WORD;
  4.   FROM M2DA IMPORT
  5.     WordSize, MaxInt, MaxDouble, ObjPtr, StrPtr, ParPtr, PDPtr,
  6.     Standard, ObjClass, StrForm, PDesc, Object, ovflchk,
  7.     notyp, undftyp, booltyp, chartyp, inttyp,
  8.     bitstyp, dbltyp, realtyp, lrltyp, proctyp,
  9.     stringtyp, addrtyp, bytetyp, wordtyp;
  10.   FROM M2SA IMPORT
  11.     Mark;
  12.   FROM M2HA IMPORT
  13.     D0, D1, SB, MP, SP,
  14.     byte, word, long,
  15.     Condition, RegType, Register, WidType, ItemMode, Item,
  16.     LongVal, WordVal, SimpleT, RealT,
  17.     GetReg, Release, ReleaseReg, SetbusyReg, SaveRegs, RestoreRegs,
  18.     SetlocMd, SetregMd, SetstkMd, SetconMd,
  19.     StackTop, SetupSL, GenHalt,
  20.     LoadD, LoadP, LoadX, Move, MoveAdr, MoveBlock, Tst1, Add2, Cmp2,
  21.     CheckClimit, CheckRange, DynArray,
  22.     Jf, Jb, EnterCase, ExitCase, Link, Unlink, CallInt, CallExt, CallInd,
  23.     EnterModule, ExitModule, InitModule,
  24.     FMove, LoadF, FMonad;
  25.   FROM M2LA IMPORT
  26.     pc, maxP, maxM, PutWord, AllocChar, FixLink, FixLinkWith, fixup;
  27.   FROM M2EA IMPORT
  28.     GlbParStartAdr, LocParStartAdr;
  29.  
  30.   VAR sp0, sp : INTEGER;
  31.  
  32.  
  33.   PROCEDURE err(n: INTEGER);
  34.     (* local synonym for M2SM.Mark to save space! *)
  35.   BEGIN
  36.     Mark(n);
  37.   END err;
  38.  
  39.   PROCEDURE Put16(w : WORD);
  40.     (* local synonym for M2LM.PutWord to save space! *)
  41.   BEGIN
  42.     PutWord(w);
  43.   END Put16;
  44.  
  45.   PROCEDURE SRTest(VAR x : Item);
  46.   BEGIN
  47.     WITH x DO
  48.       WHILE typ^.form = Range DO typ := typ^.RBaseTyp END;
  49.     END (*WITH*);
  50.   END SRTest;
  51.  
  52.   PROCEDURE setCC(VAR x : Item; fcc : Condition);
  53.     (* transform all modes to 'cocMd' : *)
  54.   BEGIN
  55.     Release(x);
  56.     WITH x DO
  57.       typ := booltyp; mode := cocMd; CC := fcc;
  58.       Tjmp := 0; Fjmp := 0;
  59.     END;
  60.   END setCC;
  61.  
  62.   PROCEDURE GenAssign(VAR x, y : Item);
  63.     (*       x    :=    y     *)
  64.     (*       y  ---->>  x     *)
  65.     (* or    g  ---->>  f     *)
  66.     VAR f, g     : StrForm;
  67.         xp, yp   : ParPtr;
  68.         x0, y0   : Item;
  69.         s, sadr  : INTEGER;
  70.         Min, Max : INTEGER;
  71.         L        : INTEGER;
  72.         sz       : WidType;
  73.         xt       : StrPtr;
  74.   BEGIN
  75.     IF (x.mode = conMd) OR (x.mode > stkMd) THEN err(134) END;
  76.     SRTest(y);
  77.     f := x.typ^.form;
  78.     g := y.typ^.form;
  79.     xt := x.typ; (* hold original type of x *)
  80.     IF f = Range THEN
  81.       (* perform range check. *)
  82.       Min := x.typ^.min; Max := x.typ^.max;
  83.       IF y.mode = conMd THEN
  84.         IF (LongVal(y) < LONG(Min)) OR (LongVal(y) > LONG(Max)) THEN
  85.           err(138)
  86.         END
  87.       ELSE
  88.         CheckRange(y, Min, Max, 0)
  89.       END;
  90.       x.typ := x.typ^.RBaseTyp;
  91.       f := x.typ^.form;
  92.     END (*Range*);
  93.  
  94.     CASE f (* destination form *) OF
  95.  
  96.       Undef :    err(133);
  97.  
  98.     | Byte :     IF y.typ^.size = 1 THEN Move(y,x)
  99.                  ELSE err(133)
  100.                  END;
  101.  
  102.     | Bool :     IF g = Bool THEN Move(y,x)
  103.                  ELSE err(133)
  104.                  END;
  105.  
  106.     | Char :     IF g = Char THEN Move(y,x)
  107.                  ELSIF g = Byte THEN Move(y,x)
  108.                  ELSE err(133)
  109.                  END;
  110.  
  111.     | Int :      IF g = Int THEN Move(y,x)
  112.                  ELSE err(133)
  113.                  END;
  114.  
  115.     | Enum :     IF x.typ = y.typ THEN Move(y,x)
  116.                  ELSE err(133)
  117.                  END;
  118.  
  119.     | Word :     IF y.typ^.size = 2 THEN Move(y,x)
  120.                  ELSE err(133)
  121.                  END;
  122.  
  123.     | LWord :    IF g = LWord THEN Move(y,x)
  124.                  ELSIF g = Double (* double constants *) THEN Move(y,x)
  125.                  ELSIF (x.typ = addrtyp) & (g = Pointer) THEN Move(y,x)
  126.                  ELSIF g = Int THEN
  127.                    IF y.mode = conMd THEN
  128.                      SetconMd(y, LongVal(y), xt);
  129.                    ELSE
  130.                      LoadX(y,long); y.typ := xt;
  131.                    END;
  132.                    Move(y,x)
  133.                  ELSE err(133)
  134.                  END;
  135.  
  136.     | Double :   IF g = Double THEN Move(y,x)
  137.                  ELSIF g = Int THEN
  138.                    IF y.mode = conMd THEN
  139.                      SetconMd(y, LongVal(y), xt);
  140.                    ELSE
  141.                      LoadX(y,long); y.typ := xt;
  142.                    END;
  143.                    Move(y,x)
  144.                  ELSE err(133)
  145.                  END;
  146.  
  147.     | Real :     IF g = Real THEN FMove(y,x)
  148.                  ELSE err(133)
  149.                  END;
  150.  
  151.     | LongReal : IF g = LongReal THEN FMove(y,x)
  152.                  ELSIF g = Real THEN
  153.                    FMonad(Long,y);
  154.                    y.typ := xt;
  155.                    FMove(y,x)
  156.                  ELSE err(133)
  157.                  END;
  158.  
  159.     | Pointer :  IF (x.typ = y.typ) OR (y.typ = addrtyp) THEN
  160.                    Move(y,x)
  161.                  ELSE err(133)
  162.                  END;
  163.  
  164.     | Set :      IF x.typ = y.typ THEN Move(y,x)
  165.                  ELSE err(133)
  166.                  END;
  167.  
  168.     | Opaque :   IF (x.typ = y.typ) THEN Move(y,x)
  169.                  ELSE err(133)
  170.                  END;
  171.  
  172.     | Record :   IF x.typ = y.typ THEN
  173.                    s := x.typ^.size;
  174.                    MoveBlock(y,x,s,FALSE)
  175.                  ELSE err(133)
  176.                  END;
  177.  
  178.     | ProcTyp :  IF y.mode = procMd THEN
  179.                    (* procedure-constant to procedure-variable : *)
  180.                    IF y.proc^.pd^.lev # 0 THEN err(127)
  181.                    ELSIF x.typ^.resTyp # y.proc^.typ THEN err(128)
  182.                    ELSE xp := x.typ^.firstPar; yp := y.proc^.firstParam;
  183.                      WHILE xp # NIL DO
  184.                        IF yp # NIL THEN
  185.                          IF (xp^.varpar # yp^.varpar) OR
  186.                             ((xp^.typ # yp^.typ) AND
  187.                             ((xp^.typ^.form # Array) OR
  188.                              NOT xp^.typ^.dyn OR
  189.                              (yp^.typ^.form # Array) OR
  190.                              NOT yp^.typ^.dyn OR
  191.                              (xp^.typ^.ElemTyp # yp^.typ^.ElemTyp))) THEN
  192.                            err(129)
  193.                          END;
  194.                          yp := yp^.next
  195.                        ELSE err(130)
  196.                        END;
  197.                        xp := xp^.next
  198.                      END (*WHILE*);
  199.                      IF yp # NIL THEN err(131) END;
  200.                      MoveAdr(y,x);
  201.                    END;
  202.                  ELSIF x.typ = y.typ THEN Move(y,x)
  203.                  ELSE err(133)
  204.                  END;
  205.  
  206.     | Array :    s := x.typ^.size;
  207.                  IF (x.typ = y.typ) & NOT(x.typ^.dyn) THEN
  208.                    MoveBlock(y,x,s,FALSE)
  209.                  ELSIF (x.mode = stkMd) & x.typ^.dyn THEN
  210.                    (* formal parameter is dynamic array : *)
  211.                    IF (g = Array) & (x.typ^.ElemTyp = y.typ^.ElemTyp) THEN
  212.                      DynArray(x,y)
  213.                    ELSE
  214.                      IF (x.typ^.ElemTyp = chartyp) OR
  215.                         (x.typ^.ElemTyp = bytetyp) THEN
  216.                        IF g = String THEN
  217.                          DynArray(x,y)
  218.                        ELSIF (g = Char) & (y.mode = conMd) THEN
  219.                          (* character-constant to dynamic array : *)
  220.                          AllocChar(y.val.Ch, sadr);
  221.                          WITH y DO
  222.                            typ := stringtyp; val.D0 := sadr; val.D1 := 2;
  223.                          END (*WITH*);
  224.                          DynArray(x,y)
  225.                        ELSIF (x.typ^.ElemTyp = bytetyp) THEN DynArray(x,y)
  226.                        ELSE err(133)
  227.                        END
  228.                      ELSE err(133)
  229.                      END
  230.                    END
  231.                  ELSIF (x.typ^.ElemTyp = chartyp) THEN
  232.                    IF x.typ^.dyn THEN err(143) END;
  233.                    IF x.typ^.IndexTyp # NIL THEN
  234.                      WITH x.typ^.IndexTyp^ DO
  235.                        IF form = Range THEN s := max - min + 1 END;
  236.                      END;
  237.                    END;
  238.                    IF g = String THEN
  239.                      (* string to fixed-size array : 4th edition *)
  240.                      (* length of string must be less than that of array! *)
  241.                      IF y.val.D1 > s THEN err(146) END;
  242.                      MoveBlock(y,x,s,TRUE);
  243.                    ELSIF (g = Char) & (y.mode = conMd) THEN
  244.                      (* character-constant to fixed-size array : *)
  245.                      AllocChar(y.val.Ch, sadr);
  246.                      WITH y DO
  247.                        typ := stringtyp; val.D0 := sadr; val.D1 := 2;
  248.                      END (*WITH*);
  249.                      IF s < 2 THEN err(146) END;
  250.                      MoveBlock(y,x,s,TRUE);
  251.                    ELSE err(133)
  252.                    END
  253.                  ELSE err(133)
  254.                  END;
  255.  
  256.     ELSE (* must not occur on the left side *)
  257.       err(133)
  258.     END (*CASE f*);
  259.     x.typ := xt; (* restore original type of x *)
  260.     Release(y);
  261.     Release(x);
  262.   END GenAssign;
  263.  
  264.   PROCEDURE GenFJ(VAR loc: INTEGER);
  265.   BEGIN
  266.     Jf(T, loc);
  267.   END GenFJ;
  268.  
  269.   PROCEDURE GenCFJ(VAR x: Item; VAR loc: INTEGER);
  270.   BEGIN
  271.     IF x.typ = booltyp THEN
  272.       IF x.mode # cocMd THEN Tst1(x); setCC(x, EQ) END;
  273.     ELSE
  274.       setCC(x, EQ); err(135);  (* type of expression must be boolean *)
  275.     END;
  276.     loc := x.Fjmp; Jf(x.CC, loc); FixLink(x.Tjmp);
  277.   END GenCFJ;
  278.  
  279.   PROCEDURE GenBJ(loc: INTEGER);
  280.   BEGIN
  281.     Jb(T, loc);
  282.   END GenBJ;
  283.  
  284.   PROCEDURE GenCBJ(VAR x: Item; loc: INTEGER);
  285.   BEGIN
  286.     IF x.typ = booltyp THEN
  287.       IF x.mode # cocMd THEN Tst1(x); setCC(x, EQ) END;
  288.     ELSE
  289.       setCC(x, EQ); err(135);  (* type of expression must be boolean *)
  290.     END;
  291.     Jb(x.CC, loc); FixLinkWith(x.Fjmp, loc); FixLink(x.Tjmp);
  292.   END GenCBJ;
  293.  
  294.   PROCEDURE SpaceForFunction(func : StrPtr);
  295.     (* reserve space on top of stack for function result. *)
  296.     VAR tos : Item;
  297.   BEGIN
  298.     SetstkMd(tos, func);
  299.     IF SimpleT(tos) OR RealT(tos) OR (func^.size IN {1,2,4,8}) THEN
  300.       StackTop( - func^.size )
  301.     ELSE
  302.       err(200)
  303.     END;
  304.   END SpaceForFunction;
  305.  
  306.   PROCEDURE PrepCall(VAR x: Item; VAR fp: ParPtr; VAR regs: LONGINT);
  307.     VAR func: StrPtr; Rn: Register;
  308.   BEGIN
  309.     Rn := 0;
  310.     WITH x DO
  311.       IF (mode = procMd) OR (mode = codMd) THEN
  312.         func := proc^.typ; fp := proc^.firstParam;
  313.       ELSIF typ^.form = ProcTyp THEN
  314.         func := typ^.resTyp; fp := typ^.firstPar;
  315.         LoadP(x);                 (* load procedure variable *)
  316.         Rn := R; ReleaseReg(Rn);  (* inhibit save of register Rn *)
  317.       ELSE
  318.         func := notyp; fp := NIL;
  319.         err(136);  (* call of an object which is not a procedure *)
  320.       END;
  321.       SaveRegs(regs);
  322.       IF Rn # 0 THEN SetbusyReg(Rn) END;  (* re-reserve register Rn *)
  323.       IF func # notyp THEN SpaceForFunction(func) END;
  324.     END (*WITH*);
  325.   END PrepCall;
  326.  
  327.   PROCEDURE GenParam(VAR ap: Item; f: ParPtr);
  328.     VAR fp: Item;
  329.   BEGIN
  330.     SetstkMd(fp, f^.typ);
  331.     IF f^.varpar THEN
  332.       IF (fp.typ^.form = Array) & fp.typ^.dyn & (fp.typ^.ElemTyp = bytetyp) THEN
  333.         DynArray(fp, ap);
  334.       ELSIF (fp.typ^.form = Array) & fp.typ^.dyn &
  335.             (ap.typ^.form = Array) & (ap.typ^.ElemTyp = fp.typ^.ElemTyp) THEN
  336.         DynArray(fp, ap);
  337.       ELSIF (ap.typ = fp.typ) OR
  338.         (fp.typ = wordtyp) & (ap.typ^.size = 2) OR
  339.         (fp.typ = bytetyp) & (ap.typ^.size = 1) OR
  340.         (fp.typ = addrtyp) & (ap.typ^.form = Pointer) THEN
  341.         IF (ap.mode = procMd) & (f^.typ^.form # ProcTyp) THEN
  342.           err(137)
  343.         ELSE
  344.           MoveAdr(ap, fp)
  345.         END;
  346.       ELSE
  347.         err(137);  (* type of VAR par is not identical to that of actual par *)
  348.       END;
  349.     ELSE
  350.       GenAssign(fp, ap);  (* type check in GenAssign *)
  351.     END;
  352.     Release(ap);
  353.   END GenParam;
  354.  
  355.   PROCEDURE RestoreResultAndRegs(VAR x : Item; regs : LONGINT);
  356.     VAR y, z : Item; sz : INTEGER;
  357.   BEGIN
  358.     WITH x DO
  359.       SetstkMd(x, typ);   (* result on top of stack *)
  360.       IF regs # 0D THEN  (* saved registers above result *)
  361.         (* Caution: saved registers remain busy, so the LoadD(x) *)
  362.         (* -------  below gets a pool-register which is NOT in   *)
  363.         (*          the set of the registers to be restored.     *)
  364.         IF SimpleT(x) THEN LoadD(x)
  365.         ELSIF RealT(x) THEN LoadF(x)
  366.         ELSE (* structured type *)
  367.           sz := typ^.size;
  368.           IF NOT(sz IN {1,2,4,8}) THEN
  369.             err(200); (* function result size not implemented! *)
  370.           ELSE
  371.             IF sz IN {1,2,4} THEN (* byte/word/long result *)
  372.               SetstkMd(z, typ);
  373.               SetregMd(y, D0, typ); Move(z,y);
  374.               RestoreRegs(regs); regs := 0D;
  375.               Move(y,z);
  376.             ELSE (* double-longword result *)
  377.               SetstkMd(z, dbltyp);
  378.               SetregMd(y, D0, dbltyp); Move(z,y);
  379.               SetregMd(y, D1, dbltyp); Move(z,y);
  380.               RestoreRegs(regs); regs := 0D;
  381.               SetregMd(y, D1, dbltyp); Move(y,z);
  382.               SetregMd(y, D0, dbltyp); Move(y,z);
  383.             EN